(ns mm.mm 
  (:gen-class)
  (:import 
   (javax.swing JFrame JButton)
   (java.awt Color
	     Canvas
	     Dimension Graphics FlowLayout)
   (java.awt.event ActionListener)
   (java.lang Thread)
   (java.awt.image BufferedImage)))

(defn color-seq [[r1 g1 b1] [r2 g2 b2] [rs gs bs]]
  (map (fn [r g b] 
	 (.getRGB 
	  (new java.awt.Color 
	       (int (Math/floor r))
	       (int (Math/floor g))
	       (int (Math/floor b)))))
       (if (== r1 r2) (cycle [r1]) (range r1 r2 rs))
       (if (== g1 g2) (cycle [g1]) (range g1 g2 gs))
       (if (== b1 b2) (cycle [b1]) (range b1 b2 bs))))

(defn color-range 
  ([num c1 c2 & cs]
     (if (== num 1)
       [(.getRGB (new java.awt.Color
		 0 0 0)) 
	(.getRGB (new java.awt.Color
		      0 0 0))]
       (let [all-colors (concat [c1 c2] cs)
	     per-range (int (/ num (- (count all-colors) 1)))]
	 (vec (mapcat #(color-range per-range %1 %2) all-colors (concat [c2] cs))))))
  ([num [r1 g1 b1] [r2 g2 b2]]
     (println num)
     (let [calc-s (fn [a b]
		    (/ (- b a) num))]
       (color-seq [r1 g1 b1] [r2 g2 b2] [(calc-s r1 r2) (calc-s g1 g2) (calc-s b1 b2)]))))

(def k 1024)
(def ram 512)
(def *memory* (make-array Integer/TYPE (* k ram)))
(def *free-memory-list* (atom [[0 (* k ram)]]))
(def *allocated-memory-list* (atom []))
(def *block-size* (* 8 k))
(def *process-colors* [(.getRGB Color/BLACK)
		       (.getRGB Color/MAGENTA)
		       (.getRGB Color/CYAN)
		       (.getRGB Color/RED)
		       (.getRGB Color/YELLOW)
		       (.getRGB Color/BLUE)
		       (.getRGB Color/GREEN)
		       (.getRGB Color/ORANGE)])

(defn partition-free-memory []
  (let [mem-size (* ram k)
	block-size *block-size*
	blocks (take-while #(<= %1 mem-size) (iterate #(+ block-size %1) 0))]
    (reset! *free-memory-list* (vec (doall (map #(vector %1 %2) blocks (rest blocks)))))))

(defn block-size [[begin end]]
  (- end begin))

(defn split-block [block size]
  (let [[begin end] block]
    [[begin (+ begin size)] [(+ begin size) end]]))

(def memory-loc (partial sort-by (fn [[b e]] b))) ;;good for merging...
(def smallest-first (partial sort-by (fn [[b e]] (- e b)))) ;;increasing size.. best fit
(def largest-first  (partial sort-by (fn [[b e]] (- b e)))) ;;decreasing size.. worst fit

;;increasing time since last use is the other option, haven't implemented yet.

(defn set-sort-fn [sort-fn]
  (defn assoc-sort [col key val]
					;(println ['assoc val])
    (vec (sort-fn (assoc col key val))))

  (defn conj-sort [col val]
					;  (println ['conj val])
    (vec (sort-fn (conj col val))))

  (defn unconj-sort [seq item]
					; (println ['unconj item])
    (vec (sort-fn (filter #(not (= %1 item)) seq))))
  
  (defn merge-free [free-list1]
    (let [free-list (memory-loc free-list1)]
      (loop [fst (first free-list)
	     tail (next free-list)
	     collection []]

					;(println collection)
	(if tail
	  (if (== (second fst) (first (first tail)))
	    (do (recur [(first fst) (second (first tail))]
		       (next tail)
		       collection))
	    (do (recur (first tail) (next tail) (conj collection fst))))
	  (vec (sort-fn (conj collection fst))))))))


(defn first-fit-block [bytes]
  (let [free-memory-list @*free-memory-list*]
    (loop [block (first free-memory-list) blocks (next free-memory-list) idx 0]
      (if (>= (block-size block) bytes)
	(let [[allocated free] (split-block block bytes)]
	  (if (== (first free) (second free))
	    allocated
	    (if (compare-and-set! *free-memory-list*
				  free-memory-list 
				  (assoc-sort free-memory-list idx free))
	      allocated
	      (first-fit-block bytes))))
	(when (first blocks)
	  (recur (first blocks) (rest blocks) (inc idx)))))))


(defn allocate-block [block pid]
  (when block
    (swap! *free-memory-list* unconj-sort block)
    (swap! *allocated-memory-list* conj-sort block)
    (let [first-block (first block)]
      (dotimes [i (- (second block) first-block)]
	(aset *memory* (+ i first-block) pid)))
    block))

(defn free-block [block]
  (when block
    (swap! *free-memory-list* conj-sort block)
    (swap! *allocated-memory-list* unconj-sort block)
    (let [first-block (first block)]
      (dotimes [i (- (second block) first-block)] 
	(aset *memory* (+ i first-block) 0)))
    block))

(defn def-allocation [block-fun]
  (fn [bytes pid]
    (when-let [block (block-fun bytes)]
      (when-let [memory-free? (split-block block bytes)]
	(let [[allocated free] memory-free?]
	  ;(println (list :block block :mf? memory-free? :allocated allocated :free free))
	  (allocate-block allocated pid)
	  block)))))

(def allocate (def-allocation first-fit-block))

(declare clear)
(declare redraw)
(declare set-image)

(defn alloc-test []
  (allocate (* 5 k) 1)
  (allocate (* 5 k) 2)
  (allocate (* 10 k) 3)
  (allocate (* 10 k) 4)
  (allocate (* 20 k) 5)
  (set-image))

(defn free-test [n]
  (free-block (nth @*allocated-memory-list* n))
  (set-image))

(defn defprocess 
  ([str-name pid kb-ram sec-on sec-off times]
     (fn []
       (dotimes [_ times]
	 (if-let [memory-block (allocate (* kb-ram k) pid)]
	   (when (not (== (first memory-block) (second memory-block)))
	     (println (str "Process: " str-name " starting " kb-ram " kb allocated!"))
	     (set-image)
	     (. Thread sleep (long (* 1000 sec-on)))
	     (free-block memory-block)
	     (set-image)
	     (println (str "Process: " str-name " ending " kb-ram " kb freed!")))
	   (println (str "Process: " str-name " cannot be started, not enough memory!")))
	 (. Thread sleep (long (* 1000 sec-off))))))

  ([str-name pid kb-ram sec-on]
     (fn []
       (if-let [memory-block (allocate (* kb-ram k) pid)]
	 (when (not (== (first memory-block) (second memory-block)))
	   (println (str "Process: " str-name " starting " kb-ram " kb allocated!"))
	   (set-image)
	   (. Thread sleep (long (* 1000 sec-on)))
	   (free-block memory-block)
	   (set-image)
	   (println (str "Process: " str-name " ending " kb-ram " kb freed!")))
	 (println (str "Process: " str-name " cannot be started, not enough memory!")))
       (. Thread sleep (long (* 1000 sec-on))))))

(defn test-procii []
  (doall (map #(.start %1)
	      (map #(new Thread %1)
		   [(defprocess "A" 1 20 1 1.5 10)
		    (defprocess "B" 2 20 3 2.5 10)
		    (defprocess "C" 3 30 2 1 10)
		    (defprocess "D" 4 60 4 1 10)
		    (defprocess "E" 5 20 3 5 10)
		    (defprocess "F" 6 90 0.6 2 10)
		    (defprocess "G" 7 20 2 3.4 10)]))))

(defn test-test-procii []
  (pvalues (test-procii)
	   (test-procii)))

  (defn smallest-first-sort []
    (set-sort-fn smallest-first)
    (test-procii))

  (defn largest-first-sort []
    (set-sort-fn largest-first)
    (test-procii))

  (defn memory-mapped-sort []
    (set-sort-fn memory-loc)
    (test-procii))

  (defn merge-fn []
    (swap! *free-memory-list* merge-free)
    (clear))

  (defn color-memory-blocks [memory-block-list]
	    (let [memory (ints *memory*) ;;obligatory unboxing
		  num-colors-needed (count memory-block-list)
		  colors-list (color-range num-colors-needed [255 0 0] [0 255 0] [0 0 255])
		  set-memory-color (fn foo [id [fst lst]]
				     (let [id2 (int id)]
				       ;(println id2)
				       (doall (map #(aset memory %1 id2)
						   (range fst lst)))))]
	      (doall (pmap set-memory-color 
			   (range (- num-colors-needed 1))
			   memory-block-list))
	      (set-image colors-list)))

(defn color-free-blocks []
  (if (> (count @*free-memory-list*) 1)    
    (color-memory-blocks @*free-memory-list*)
    (clear)))

(defn init []
  (let [x k
	y ram
	xi 20
	yi 20
	image (new BufferedImage x y BufferedImage/TYPE_INT_RGB)
	canvas (proxy [Canvas] []
		 (paint [g]
			(doto g
			  (.drawImage image 0 0 Color/red nil))))
	frame (doto (new JFrame)
		(.add canvas "Center")
		(.setSize (new Dimension x (+ 22 y)))
		(.setVisible true))]

    

    (defn redraw []
      (.repaint canvas))

    (defn set-image 
      ([colors]
	 (dotimes [i x]
	   (dotimes [j y]
	     (let [idx (+ i (* (int x) j))
		   pid (or (aget *memory* idx) 0)]
	       (.setRGB image i j (int (nth colors pid))))))
	 (redraw))
      ([]
	 (dotimes [i x]
	   (dotimes [j y]
	     (let [idx (+ i (* (int x) j))
		   pid (or (aget *memory* idx) 0)]
	       (.setRGB image i j (int (nth *process-colors* pid))))))
	 (redraw)))

    (defn clear []
      (dotimes [i (count *memory*)]
	(aset *memory* i 0))
      (set-image)))

  (let [al-fn (fn [button fun]
		(.addActionListener
		 button 
		 (proxy [ActionListener] []
		   (actionPerformed [e]
				    (fun))))
		button)
	button-frame (new JFrame "Buttons")]
    (doto button-frame
      (.. (getContentPane) 
	  (setLayout (new FlowLayout))))

    (let [content (.getContentPane button-frame)]
      (doto content
	(.add 
	 (al-fn (new JButton "smallest first") smallest-first-sort))
	(.add 
	 (al-fn (new JButton "largest first") largest-first-sort))
	(.add 
	 (al-fn (new JButton "memory mapped") memory-mapped-sort))
	(.add 
	 (al-fn (new JButton "merge free blocks") merge-fn))
	(.add 
	 (al-fn (new JButton "color fragmented blocks") color-free-blocks))))
    (.setVisible button-frame true)
    (.pack button-frame)))

(defn -main [& args]
  (init))